#lang racket


(require "../base/main.rkt")

(require "parametric.rkt")

(provide t-fn-min
         t-fn-half
         t-fn-max
         
         u-fn-min
         u-fn-half
         u-fn-max
         
         v-fn-min
         v-fn-half
         v-fn-max
         
         cut-fn-linear
         cut-fn-integral
         
         coords-fn-min
         
         ; domain
         (struct-out domain)
         
         (struct-out t-domain)
         make-t-domain
         
         domain-t-min-s
         domain-t-min-val
         domain-t-max-s
         domain-t-max-val
         
         (struct-out uv-domain)
         make-uv-domain
         
         domain-u-min-s
         domain-u-min-val
         domain-u-max-s
         domain-u-max-val
         
         domain-v-min-s
         domain-v-min-val
         domain-v-max-s
         domain-v-max-val
         
         
         ;cut
         cut-t-domain
         cut-uv-domain
         cut-domain
         
         coords-t-domain
         coords-uv-domain
         coords-domain)


; interval

;; cut-fn

(define (cut-fn-linear)
  (λ (interval n-intervals)
    (if (= n-intervals 1)
        interval
        (let* ((min (interval-min-val interval))
               (max (interval-max-val interval))
               (step (/ (- max min) n-intervals))
               (first-interval (make-interval (interval-min-s interval) min 'closed (+ min step)))
               (last-interval (make-interval 'closed (- max step) (interval-max-s interval) max)))
          (append
           (list first-interval)
           (map 
            (λ (val)
              (make-interval 'closed val 'closed (+ val step)))
            (: > min .. step .. < (- n-intervals 2) > <))
           (list last-interval))))))

; edit
(define (cut-fn-integral)
  (λ (interval n-segments)
    (error 'cut-fn-integral "Closure not implemented")))


;; coords-fn

(define (coords-fn-min)
  (λ (int n-coords)
    (match int
      ((struct interval ('open min-val 'open max-val))
       (let ((step (/ (- max-val min-val) (+ n-coords 1))))
         (: > min-val .. step .. < n-coords > <)))
      ((struct interval ('open min-val 'closed max-val))
       (let ((step (/ (- max-val min-val) n-coords)))
         (: > min-val .. step .. < n-coords > <)))
      ((struct interval ('closed min-val 'open max-val))
       (let ((step (/ (- max-val min-val) n-coords)))
         (: > min-val .. step .. < n-coords > <)))
      ((struct interval ('closed min-val 'closed max-val))
       (let ((step (/ (- max-val min-val) (- n-coords 1))))
         (: > min-val .. step .. < n-coords > <))))))


;; t-fn

(define (t-fn-min)
  (λ (interval)
    (when (eq? (interval-min-s interval) 'open)
      (raise unsupported "Min strategy is not applicable to an interval with an open lower bound"))
    (interval-min-val interval)))

(define (t-fn-half)
  (λ (interval)
    (let ((a (interval-min-val interval))
          (b (interval-max-val interval)))
      (/2 (+ a b)))))

(define (t-fn-max)
  (λ (interval)
    (when (eq? (interval-max-s interval) 'open)
      (raise unsupported "Max strategy is not applicable to an interval with an open upper bound"))
    (interval-max-val interval)))

(define u-fn-min t-fn-min)
(define u-fn-half t-fn-half)
(define u-fn-max t-fn-max)

(define v-fn-min t-fn-min)
(define v-fn-half t-fn-half)
(define v-fn-max t-fn-max)


(define (cut-interval interval n-intervals cut-fn)
  (cut-fn interval n-intervals))

(define (coords-interval interval n-coords coords-fn)
  (coords-fn interval n-coords))


; domain

(define-struct domain ())


;; t-domain

(define (t-domain-print domain port mode)
  (write-string "domain(" port)
  (write (t-domain-t domain) port)
  (write-string ")" port))

(define-struct (t-domain domain)
  (t)
  #:constructor-name new-t-domain
  #:property prop:custom-write t-domain-print)

(define (make-t-domain min-s min-val max-s max-val)
  (new-t-domain (make-interval min-s min-val max-s max-val)))


(define (domain-t-min-s t-domain)
  (interval-min-s (t-domain-t t-domain)))

(define (domain-t-min-val t-domain)
  (interval-min-val (t-domain-t t-domain)))

(define (domain-t-max-s t-domain)
  (interval-max-s (t-domain-t t-domain)))

(define (domain-t-max-val t-domain)
  (interval-max-val (t-domain-t t-domain)))


;; uv-domain

(define (uv-domain-print domain port mode)
  (write-string "domain(" port)
  (write (uv-domain-u domain) port)
  (write-string "," port)
  (write (uv-domain-v domain) port)
  (write-string ")" port))

(define-struct (uv-domain domain)
  (u v)
  #:constructor-name new-uv-domain
  #:property prop:custom-write uv-domain-print)

(define (make-uv-domain u-min-s u-min-val u-max-s u-max-val
                        v-min-s v-min-val v-max-s v-max-val)
  (new-uv-domain
   (make-interval u-min-s u-min-val u-max-s u-max-val)
   (make-interval v-min-s v-min-val v-max-s v-max-val)))


(define (domain-u-min-s uv-domain)
  (interval-min-s (uv-domain-u uv-domain)))

(define (domain-u-min-val uv-domain)
  (interval-min-val (uv-domain-u uv-domain)))

(define (domain-u-max-s uv-domain)
  (interval-max-s (uv-domain-u uv-domain)))

(define (domain-u-max-val uv-domain)
  (interval-max-val (uv-domain-u uv-domain)))


(define (domain-v-min-s uv-domain)
  (interval-min-s (uv-domain-v uv-domain)))

(define (domain-v-min-val uv-domain)
  (interval-min-val (uv-domain-v uv-domain)))

(define (domain-v-max-s uv-domain)
  (interval-max-s (uv-domain-v uv-domain)))

(define (domain-v-max-val uv-domain)
  (interval-max-val (uv-domain-v uv-domain)))


; cut

(define (cut-t-domain t-domain t-segments cut-fn)
  (let ((intervals (cut-interval (t-domain-t t-domain) t-segments cut-fn)))
    (map new-t-domain intervals)))

(define (cut-uv-domain uv-domain u-segments v-segments u-cut-fn v-cut-fn)
  (let ((u-intervals (cut-interval (uv-domain-u uv-domain) u-segments u-cut-fn))
        (v-intervals (cut-interval (uv-domain-v uv-domain) v-segments v-cut-fn)))
    (flatten
     (for/list ((u-interval u-intervals))
       (for/list ((v-interval v-intervals))
         (new-uv-domain u-interval v-interval))))))

(define (cut-domain domain n-domains cut-fn)
  (cond ((t-domain? domain)
         (cut-t-domain domain n-domains cut-fn))
        ((uv-domain? domain)
         (cut-uv-domain domain
                        (first n-domains) (second n-domains)
                        (first cut-fn) (second cut-fn)))
        (else
         (error 'cut-domain "Unhandled domain type"))))


; coords

(define (coords-t-domain
         t-domain
         n-coords
         space-fn
         coords-fn)
  (map space-fn (coords-interval (t-domain-t t-domain) n-coords coords-fn)))

(define (coords-uv-domain
         uv-domain
         u-coords
         v-coords
         space-fn
         u-coords-fn
         v-coords-fn)
  (for/list ((u-coord (coords-interval (uv-domain-u uv-domain) u-coords u-coords-fn)))
    (for/list ((v-coord (coords-interval (uv-domain-v uv-domain) v-coords v-coords-fn)))
      (space-fn u-coord v-coord))))

(define (coords-domain domain n-coords space-fn coords-fn)
  (cond ((t-domain? domain)
         (coords-t-domain domain n-coords space-fn coords-fn))
        ((uv-domain? domain)
         (coords-uv-domain domain
                           (first n-coords) (second n-coords)
                           space-fn
                           (first coords-fn) (second coords-fn)))
        (else
         (error 'coords-domain "Unhandled domain type"))))